Developer CD Series 1996 May: Tool Chest/Developer CD Series May 1996 (Tool Chest) (Apple Computer) (1996).iso/Tool Chest/Development Tools & Languages/Macintosh Common Lisp Related/Drag and Drop/drag-and-drop.lisp

Text File | 1994-09-12 | 43.8 KB | 1,044 lines | [TEXT/CCL2]

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;
;;;; Macintosh Drag and Drop for MCL
;;;;
;;;; Almost, but quite all of the Macintosh Drag Manager is implemented here.
;;;; There are a couple of bonuses, though, the biggest being that the
;;;; implementation easily supports drag and drop behavior among views in a
;;;; window.
;;;;
;;;; General usage notes:
;;;;
;;;; ¥ In order to drag items from a view or receive drops the view's window
;;;;   must include 'drag-&-drop-window-mixin class its definition.
;;;; ¥ If you want a particular view to be able to receive a drop, make sure
;;;;   you've specialized the 'drag-receive-drag method.
;;;; ¥ If you want be able to drag items out of a particular view, specialize
;;;;   the 'drag-selection-p method.
;;;; ¥ Events from the Drag Manager are piped through a dispatching function
;;;;   and sent to MCL methods, which you should specialize.  The methods
;;;;   are all named 'drag-tracking-xxxx.
;;;;
;;;; Following the Real Code are a couple of examples.  The first is a subclass
;;;; of fred, allowing you to drag selections out as either text data (to other
;;;; text-oriented applications), text clipping files in the Finder or as MCL
;;;; files in the Finder.  The second example is a simple view with two text
;;;; fields that allow dragging and dropping between them.  Both examples allow
;;;; you to drop text data, text clipping files and text documents into their
;;;; respective drop locations.  After evaluating the commented code you can
;;;; bring up the examples via (fred-example) and (text-item-example) in the
;;;; Listener.
;;;;
;;;; Please let me know if you have any suggestions, comments or bug reports!
;;;;
;;;; Dan S. Camper
;;;; [e-mail]
;;;; 8/24/94
;;;;

(in-package :ccl)

(require :quickdraw)

(export '(drag-&-drop-window-mixin
          drag-reference drag-region tracking-handler receive-handler
          drag-window-p

          drag-tracking-enter-handler drag-tracking-leave-handler
          drag-tracking-enter-view drag-tracking-leave-view
          drag-tracking-in-view

          drag-manager-present-p

          drag-attributes
          drag-within-sender-application-p
          drag-left-sender-window-p drag-left-sender-view-p
          drag-within-sender-window-p drag-within-sender-view-p

          drag-item-count
          drag-item-reference-number
          drag-item-flavor-count
          drag-item-flavor-type drag-item-flavor-type-list
          drag-item-flavor-flags
          drag-item-flavor-size
          drag-item-flavor-data with-drag-item-flavor-data
          drag-item-flavor-exists-p
          with-drag-items

          with-new-drag
          drag-add-item-flavor
          drag-set-item-flavor-data
          drag-promise-item-flavor
          drag-add-hfs-flavor
          drag-promise-hfs-flavor
          drag-begin-drag
          drag-send-data
          drag-selection-p
          $PromisedHFSObject

          drag-receive-drag
          drag-get-drop-location drag-get-drop-location-as-path

          view-drag-hilite
          find-view-containing-global-point
          drag-mouse-location drag-mouse-view
          create-drag-item-bounds
          wptr-to-drag-window drag-window-to-wptr drag-reference-to-window))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Low-level stuff....
;;;

(defvar *drag-&-drop-window-list* nil)
(defconstant $PromisedHFSObject :|HFSp|)

(defmacro oserr-check (&body body)
  (let ((result (gensym)))
    `(let ((,result (progn ,@body)))
       (cond ((eql ,result #$userCanceledErr)
              (throw-cancel ,result))
             ((neq ,result #$noErr)
              (error "~S" ,result)))
       ,result)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Patch to MCL event system
;;;
;;; A hook into MCL's mouseDown handling.  All drags initiated from MCL pass
;;; through here first.
;;;
(let ((*warn-if-redefine-kernel* nil))

  (defun process-multi-clicks (event)
    ;called by event-dispatch on mouse-down events
    (rlet ((wptr :WindowPtr))
      (let ((the-part (#_FindWindow (rref event eventrecord.where) wptr))
            (view nil)
            (window nil))
        (if (and (= the-part #$inContent)
                 (setf window (wptr-to-drag-window (%get-ptr wptr)))
                 (setf view (find-view-containing-global-point window (rref event eventrecord.where)))
                 (drag-selection-p view (rref event eventrecord.where))
                 (#_WaitMouseMoved (rref event eventrecord.where)))
          (unwind-protect
            (progn
              (setf (%source-view window) view)
              (drag-begin-drag view event))
            (setf (%source-view window) nil))
          ; one of the above tests failed; do the usual thing
          (if (and (%i< (%i- (rref event eventrecord.when) *last-mouse-down-time*)
                        (%get-long (%int-to-ptr #$DoubleTime)))
                   (double-click-spacing-p *last-mouse-down-position*
                                           (rref event eventrecord.where)))
            (incf *multi-click-count*)
            (setf *last-mouse-down-position* (rref event eventrecord.where)
                  *multi-click-count* 1)))))
    (setq *last-mouse-down-time* (rref event eventrecord.when)))

  )

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; ¥¥¥ Low-level entries to/from Drag Manager
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; The system calls this function whenever a dragged item causes an event in a
;; drag & drop window.  Following is the default version; a different routine can
;; be specified with :tracking-handler argument during the window's make-instance.
;;
;; This default version acts as a dispatcher to predefined MCL methods, which you
;; should specialize as necessary.  The methods to specialize are:
;;
;;    drag-tracking-enter-handler
;;    drag-tracking-leave-handler
;;    drag-tracking-enter-view
;;    drag-tracking-leave-view
;;    drag-tracking-in-view
;;
;; This spoofs the normal Drag Manager behavior quite a bit.  Basically, we're
;; allowing window-like drag behavior from subviews in the window.
;;
(defpascal DragTrackingHandlerDispatch.p (:word $theMessage :ptr $theWindow :ptr $handlerRefCon
                                                :long $dragReference
                                                :word)
  (declare (ignore $handlerRefcon))
  (let ((w (wptr-to-drag-window $theWindow))
        (old-ref 0))
    (when w
      (unwind-protect
        (progn
          (setf old-ref (drag-reference w)      ; save old reference and restore when completed
                (slot-value w 'drag-reference) $dragReference)
          (case $theMessage
            (#.#$dragTrackingEnterHandler
             (drag-tracking-enter-handler w))
            (#.#$dragTrackingEnterWindow
             (let ((v (drag-mouse-view w)))
               (drag-tracking-enter-view v)
               (setf (%last-view w) v)))
            (#.#$dragTrackingInWindow
             (let ((v (drag-mouse-view w)))
               (unless (equal (%last-view w) v)   ; see if we're switching views and adjust if necessary
                 (when (%last-view w)
                   (drag-tracking-leave-view (%last-view w)))
                 (when v
                   (drag-tracking-enter-view v)))
               (drag-tracking-in-view v)
               (setf (%last-view w) v)))
            (#.#$dragTrackingLeaveWindow
             (let ((v (drag-mouse-view w)))
               (drag-tracking-leave-view v))
             (setf (%last-view w) nil))
            (#.#$dragTrackingLeaveHandler
             (drag-tracking-leave-handler w))))
        (setf (slot-value w 'drag-reference) old-ref))))
  #$noErr)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; The system calls this function when an item or items are being dropped into a
;; drag & drop window.  Following is the default version; a different routine can
;; be specified with :receive-handler argument during the window's make-instance.
;;
;; Specialize the 'drag-receive-drag function for your view in order to receive
;; drops from the Drag Manager.
;;
(defpascal DragReceiveHandlerDispatch.p (:ptr $theWindow :ptr $handlerRefCon :long $dragReference
                                              :word)
  (declare (ignore $handlerRefcon))
  (let ((w (wptr-to-drag-window $theWindow))
        (old-ref 0)
        (result #$dragNotAcceptedErr))
    (when w
      (unwind-protect
        (progn
          (setf old-ref (drag-reference w)      ; save old reference and restore when completed
                (slot-value w 'drag-reference) $dragReference
                result (drag-receive-drag (drag-mouse-view w))))
        (setf (slot-value w 'drag-reference) old-ref)))
    (cond ((eql result t) (setf result #$noErr))
          ((not (integerp result)) (setf result #$dragNotAcceptedErr)))
    result))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; This function is called when the destination requests item data that was not cached.
;; It's basically a dispatch routine; specialize the 'drag-send-data method to
;; implement.
;;
;; The actual definition of this callback cites a long (actually a parameter of type
;; 'flavorType' which is an OSType which is four bytes) but there seems to be a bug in
;; the defpascal macro (or something).  If you specify a long there then the four high
;; bits are always set.  Defining it as a pointer and then extracting it with %ptr-to-int
;; seems to work.
;;
(defpascal DragSendDataProc.p (:ptr $flavorType :ptr $handlerRefCon :long $itemReference
                                     :long $dragReference
                                     :word)
  (declare (ignore $handlerRefcon))
  (let ((w (drag-reference-to-window $dragReference))
        (flavor-type nil)
        (result #$noErr))
    (when w
      (rlet ((temp :longint))
        (%put-long temp (%ptr-to-int $flavorType))
        (setf flavor-type (%get-ostype temp))
        (setf result (drag-send-data (%source-view w) $itemReference flavor-type))
        (cond ((eql result t) (setf result #$noErr))
              ((not (integerp result)) (setf result #$badDragFlavorErr)))))
    result))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; ¥¥¥ Class Definitions for drag & drop windows
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defclass drag-&-drop-window-mixin ()
  ((drag-reference :initform 0 :reader drag-reference)
   (tracking-handler :initform DragTrackingHandlerDispatch.p :initarg :tracking-handler :reader tracking-handler)
   (receive-handler :initform DragReceiveHandlerDispatch.p :initarg :receive-handler :reader receive-handler)
   (%last-view :initform nil :accessor %last-view)
   (%source-view :initform nil :accessor %source-view)
   (drag-region :initform nil :accessor drag-region)
   ))

(defmethod initialize-instance :after ((w drag-&-drop-window-mixin) &rest initargs)
  (declare (ignore initargs))
  (push (cons (wptr w) w) *drag-&-drop-window-list*)
  (oserr-check (#_InstallTrackingHandler (tracking-handler w) (wptr w) (%null-ptr)))
  (oserr-check (#_InstallReceiveHandler (receive-handler w) (wptr w) (%null-ptr)))
  )

(defmethod window-close :before ((w drag-&-drop-window-mixin))
  ; Cleanup the window's internal data
  (setf *drag-&-drop-window-list* (delete (wptr w) *drag-&-drop-window-list* :key #'car))
  (when (drag-region w)
    (dispose-region (drag-region w))
    (setf (drag-region w) nil))
  (ignore-errors (#_DisposeDrag (drag-reference w)))
  (when (tracking-handler w)
    (oserr-check (#_RemoveTrackingHandler (tracking-handler w) (wptr w)))
    (setf (slot-value w 'tracking-handler) nil))
  (when (receive-handler w)
    (oserr-check (#_RemoveReceiveHandler (receive-handler w) (wptr w)))
    (setf (slot-value w 'receive-handler) nil)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; ¥¥¥ The following methods should be shadowed by the user to get actual
;; ¥¥¥ behavior.  Note that some functions should be specialized on the window
;; ¥¥¥ while others can go down to a view.  The argument name is an indication
;; ¥¥¥ of which is which.
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; Called whenever a particular drag handler is called for the first time.
;;
(defmethod drag-tracking-enter-handler ((window t))
  (declare (ignore window))
  nil)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; Called whenever a drag enters a drag & drop window or a view within the
;; window.
;;
(defmethod drag-tracking-enter-view ((view t))
  (declare (ignore view))
  nil)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; Called while a drag is occuring within a view within a drag & drop window.
;;
(defmethod drag-tracking-in-view ((view t))
  (declare (ignore view))
  nil)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; Called whenever a drag leaves a drag & drop window or a subview.
;;
(defmethod drag-tracking-leave-view ((view t))
  (declare (ignore view))
  nil)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; Called whenever a drag is exiting a particular drag handler.
;;
(defmethod drag-tracking-leave-handler ((window t))
  (declare (ignore window))
  nil)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; Called when the Drag Manager is dropping something into a drag & drop window
;; or subview.
;;
(defmethod drag-receive-drag ((view t))
  (declare (ignore view))
  nil)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; Boolean indicating whether it's appropriate to begin a drag or not.
;; Should take into account such things as hilited items, where the mouse
;; is, etc..  Note that the mouse position is in global coordinates.
;;
(defmethod drag-selection-p ((view t) global-mouse-position)
  (declare (ignore view global-mouse-position))
  nil)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; Called at the start of a drag from a view within a drag & drop window.
;; EventRecord is a the standard Macintosh event record that is currently
;; being processed.
;;
(defmethod drag-begin-drag ((view t) eventrecord)
  (declare (ignore view eventrecord))
  nil)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; Called when destination needs item data that was not cached.  The view
;; argument will be the view the drag initiated from.  Note that the 'flavor'
;; argument is an OSType.
;;
(defmethod drag-send-data ((view t) (item-reference integer) (flavor keyword))
  (declare (ignore view item-reference flavor))
  nil)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; ¥¥¥ Drag Toolkit
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; Boolean indicating the presence of the Drag Manager in the current system.
;;
(defun drag-manager-present-p ()
  (logbitp #$gestaltDragMgrPresent (gestalt #$gestaltDragMgrAttr)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; Provides the Drag Manager default hiliting of destination windows (drawing
;; the gray border around the inside of the window's edge).  Spoofed to
;; automatically perform this behavior on the view.
;;
(defmethod view-drag-hilite ((view simple-view) hilite-p &optional (topleft nil) (bottomright nil))
  (let ((window (view-window view))
        (result nil))
    (if hilite-p
      (let ((region (new-region)))
        (multiple-value-bind (topcorner bottomcorner) (view-corners view)
          (unless (integerp topleft)
            (setf topleft topcorner))
          (unless (integerp bottomright)
            (setf bottomright bottomcorner)))
        (with-focused-view window
          (oserr-check (#_ShowDragHilite (drag-reference window) (set-rect-region region topleft bottomright) t)))
        (dispose-region region)
        (setf result t))
      (progn
        (with-focused-view window
          (oserr-check (#_HideDragHilite (drag-reference window))))))
    result))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; Testing to see if an MCL object or WindowRecord pointer can accept drags
;;
(defmethod drag-window-p ((window-or-ptr macptr))
  (if (wptr-to-drag-window window-or-ptr)
    t))

(defmethod drag-window-p ((window-or-ptr drag-&-drop-window-mixin))
  t)

(defmethod drag-window-p ((window-or-ptr t))
  nil)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; This hopefully makes the process of starting a new drag a bit easier.  The
;; setup-form argument should be a single Lisp form to execute before the Drag Manager's
;; #_TrackDrag routine is called; cleanup-form is optional but, if included,
;; should also be a single Lisp form that is called after the tracking is complete.
;; Both forms can assume the presence of a valid Drag Reference and associated
;; information.
;;
;; As an added bonus this macro always installs the DragSendDataProc.p callback
;; routine, which serves as a dispatcher to the 'drag-send-data MCL method.
;;
(defmacro with-new-drag (window eventrecord setup-form &optional (cleanup-form nil))
  (let (($DragRef (gensym))
        (setup-result (gensym))
        (cleanup-result (gensym)))
    `(let ((,setup-result nil)
           (,cleanup-result nil))
       (rlet ((,$DragRef :DragReference))
         (oserr-check (#_NewDrag ,$DragRef))
         (setf (slot-value ,window 'drag-reference) (%get-long ,$DragRef)
               (drag-region ,window) (new-region))
         (unwind-protect
           (progn
             (oserr-check (#_SetDragSendProc (drag-reference ,window) DragSendDataProc.p (%null-ptr)))
             (setf ,setup-result (progn ,setup-form))
             (oserr-check (#_TrackDrag (drag-reference ,window) ,eventrecord (drag-region ,window)))
             (if ,cleanup-form
               (setf ,cleanup-result (progn ,cleanup-form))))
           (progn
             (dispose-region (drag-region ,window))
             (setf (drag-region ,window) nil)
             (oserr-check (#_DisposeDrag (drag-reference ,window)))
             (setf (slot-value ,window 'drag-reference) 0))))
       (values ,setup-result ,cleanup-result))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; Conversion routines
;;
(defmethod wptr-to-drag-window ((window-ptr macptr))
  (cdr (find window-ptr *drag-&-drop-window-list* :key #'car)))

(defmethod drag-window-to-wptr ((window drag-&-drop-window-mixin))
  (wptr window))

(defmethod drag-reference-to-window ((reference integer))
  (cdr (find reference *drag-&-drop-window-list* :key #'(lambda (x) (drag-reference (cdr x))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; Obtaining the attributes of a particular drag.  General first, then
;; specific predicates.
;;
(defmethod drag-attributes ((window drag-&-drop-window-mixin))
  (rlet ((flags :DragAttributes))
    (oserr-check (#_GetDragAttributes (drag-reference window) flags))
    (%get-long flags)))

(defmethod drag-left-sender-window-p ((window drag-&-drop-window-mixin))
  (and (drag-window-p window)
       (logtest #$dragHasLeftSenderWindow (drag-attributes window))))

(defmethod drag-left-sender-view-p ((view simple-view))
  (let ((window (view-window view)))
    (and (drag-window-p window)
         (or (drag-left-sender-window-p window)
             (not (equal (%source-view window) (drag-mouse-view window)))))))

(defmethod drag-within-sender-application-p ((window drag-&-drop-window-mixin))
  (and (drag-window-p window)
       (logtest #$dragInsideSenderApplication (drag-attributes window))))

(defmethod drag-within-sender-window-p ((window drag-&-drop-window-mixin))
  (and (drag-window-p window)
       (logtest #$dragInsideSenderWindow (drag-attributes window))))

(defmethod drag-within-sender-view-p ((view simple-view))
  (let ((window (view-window view)))
    (and (drag-within-sender-window-p window)
         (equal (%source-view window) (drag-mouse-view window)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; Returns the number of items in a drag
;;
(defmethod drag-item-count ((window drag-&-drop-window-mixin))
  (rlet ((count :signed-integer))
    (oserr-check (#_CountDragItems (drag-reference window) count))
    (%get-word count)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; Returns the drag item reference number of the nth item.
;;
(defmethod drag-item-reference-number ((window drag-&-drop-window-mixin) &optional (index 1))
  (rlet ((item :ItemReference))
    (oserr-check (#_GetDragItemReferenceNumber (drag-reference window) index item))
    (%get-long item)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; Returns the number of flavors in a given drag item.
;;
(defmethod drag-item-flavor-count ((window drag-&-drop-window-mixin) (item-reference integer))
  (rlet ((count :signed-integer))
    (let ((err (#_CountDragItemFlavors (drag-reference window) item-reference count)))
      (if (eql err #$noErr)
        (%get-word count)
        0))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; Obtains the flavor for a given item.
;;
(defmethod drag-item-flavor-type ((window drag-&-drop-window-mixin) (item-reference integer)
                                  &optional (flavor-index 1))
  (rlet ((flavor :ostype))
    (let ((err (#_GetFlavorType (drag-reference window) item-reference flavor-index flavor)))
      (if (eql err #$noErr)
        (%get-ostype flavor)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; Build a list of flavor types for the given drag item.  The position of types in
;; the returned list is the same as the relative ordering in the actual drag item.
;;
(defmethod drag-item-flavor-type-list ((w drag-&-drop-window-mixin) (item-reference integer))
  (let ((flavor-list nil)
        (count (drag-item-flavor-count w item-reference)))
    (dotimes (index count)
      (push (drag-item-flavor-type w item-reference (1+ index)) flavor-list))
    (reverse flavor-list)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; Obtains the flavor flags for a given item.  Note that the 'flavor' argument is
;; an OSType.
;;
(defmethod drag-item-flavor-flags ((window drag-&-drop-window-mixin) (flavor keyword)
                                   (item-reference integer))
  (rlet ((flags :FlavorFlags))
    (let ((err (#_GetFlavorFlags (drag-reference window) item-reference flavor flags)))
      (if (eql err #$noErr)
        (%get-long flags)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; Boolean indicating whether a particular flavor in an item is available.  Note
;; that the 'flavor' argument is an OSType.
;;
(defmethod drag-item-flavor-exists-p ((window drag-&-drop-window-mixin) (flavor keyword)
                                      (item-reference integer))
  (if (drag-item-flavor-flags window flavor item-reference)
    t))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; Obtains the size of a particular item's flavor.  Note that the 'flavor' argument
;; is an OSType.
;;
(defmethod drag-item-flavor-size ((window drag-&-drop-window-mixin) (flavor keyword)
                                  (item-reference integer))
  (rlet ((size :size))
    (oserr-check (#_GetFlavorDataSize (drag-reference window) item-reference flavor size))
    (%get-long size)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; Obtains the data for a particular item's flavor.  Note that the 'flavor' argument
;; is an OSType.  Also note that if the function succeeds (ie, it returns a pointer)
;; then you MUST eventually dispose of the pointer!
;;
(defmethod drag-item-flavor-data ((window drag-&-drop-window-mixin) (flavor keyword)
                                  (item-reference integer))
  (let ((size (drag-item-flavor-size window flavor item-reference)))
    (rlet ((size-ptr :integer))
      (when (and (numberp size) (plusp size))
        (%put-word size-ptr size)
        (let ((data-ptr (#_NewPtr size)))
          (oserr-check (#_GetFlavorData (drag-reference window) item-reference flavor data-ptr size-ptr 0))
          data-ptr)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; Easy way to work with a particular flavor of data.  Note that the 'flavor'
;; argument is an OSType.
;;
(defmacro with-drag-item-flavor-data ((data-symbol window flavor item-reference) &body body)
  (let ((result (gensym)))
    `(let ((,result nil)
           (,data-symbol (drag-item-flavor-data ,window ,flavor ,item-reference)))
       (when ,data-symbol
         (unwind-protect
           (setf ,result (progn ,@body))
           (#_DisposePtr ,data-symbol)))
       ,result)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; Macro for iterating through all the items in a drag
;;
(defmacro with-drag-items ((ref-symbol window) &body body)
  (let ((item-count (gensym)))
    `(let ((,item-count (drag-item-count ,window)))
       (when (plusp ,item-count)
         (dotimes (counter ,item-count)
           (let ((,ref-symbol (drag-item-reference-number ,window (1+ counter))))
             (progn ,@body)))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; Setting a flavor's data (usually called from the send procedure)
;;
(defmethod drag-set-item-flavor-data ((window drag-&-drop-window-mixin) (item-reference integer)
                                      (flavor keyword) (item-ptr macptr) (item-size integer)
                                      &optional (offset 0))
  (oserr-check (#_SetDragItemFlavorData (drag-reference window) item-reference flavor item-ptr item-size offset))
  t)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; Here's where you add a flavor to a drag MCL initiates.
;;
(defmethod drag-add-item-flavor ((window drag-&-drop-window-mixin) (item-reference integer)
                                 (flavor keyword) (item-ptr macptr) (item-size integer)
                                 &optional (flags 0))
  (oserr-check (#_AddDragItemFlavor (drag-reference window) item-reference flavor item-ptr item-size flags))
  t)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; Promising a flavor...
;;
(defmethod drag-promise-item-flavor ((window drag-&-drop-window-mixin) (item-reference integer)
                                     (flavor keyword) &optional (flags 0))
  (oserr-check (#_AddDragItemFlavor (drag-reference window) item-reference flavor (%null-ptr) 0 flags))
  t)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; Adding HFS objects as flavors
;;
(defmethod drag-add-hfs-flavor ((window drag-&-drop-window-mixin) (item-reference integer) path)
  (let ((result nil))
    (when (or (pathnamep path) (stringp path))
      (with-pstrs ((path-str (mac-namestring path)))
        (rlet (($fs :FSSpec)
               ($info :FInfo)
               ($hfs :HFSFlavor
                     :fileSpec $fs))
          (oserr-check (#_FSMakeFSSpec 0 0 path-str $fs))
          (oserr-check (#_FSPGetFInfo $fs $info))
          (setf (pref $hfs :HFSFlavor.fdFlags) (pref $info :FInfo.fdFlags)
                (pref $hfs :HFSFlavor.fileType) (pref $info :FInfo.fdType)
                (pref $hfs :HFSFlavor.fileCreator) (pref $info :FInfo.fdCreator))
          (setf result (drag-add-item-flavor window item-reference #$flavorTypeHFS
                                             $hfs #.(record-length :HFSFlavor))))))
    result))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; Promising HFS objects.
;;
;; Promising an HFS object involves a bizarre little two-step inside Drag Manager
;; callback routines.  Basically, if you promise an HFS object then you should
;; also include a 'drag-send-data method that is specialized on both your view and
;; on the flavor $PromisedHFSObject.  Your 'drag-send-data should then create the
;; file and set the flavor's data to the file's FSSpec record.  See the 'fred-example
;; example for clarification.
;;
(defmethod drag-promise-hfs-flavor ((window drag-&-drop-window-mixin) (item-reference integer)
                                    (file-type keyword) (file-creator keyword)
                                    &key
                                    (hasBeenInited nil)
                                    (isStationery nil)
                                    (namedLocked nil)
                                    (fHasBundle nil)
                                    (fIsInvisible nil)
                                    (isAlias nil))
  (let ((finder-flags 0))
    (if hasBeenInited (incf finder-flags #X0100))       ; set the appropriate bits here
    (if isStationery (incf finder-flags #X0800))
    (if namedLocked (incf finder-flags #X1000))
    (if fHasBundle (incf finder-flags #X2000))
    (if fIsInvisible (incf finder-flags #X4000))
    (if isAlias (incf finder-flags #X8000))
    (rlet (($promise :PromiseHFSFlavor
                     :fileType file-type
                     :fileCreator file-creator
                     :fdFlags finder-flags
                     :promisedFlavor $PromisedHFSObject))
      (drag-promise-item-flavor window item-reference $PromisedHFSObject)
      (drag-add-item-flavor window item-reference #$flavorTypePromiseHFS $promise
                            #.(record-length :PromiseHFSFlavor)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; Same as MCL's #'find-view-containing-point but assumes a global mouse location
;;
(defmethod find-view-containing-global-point ((view simple-view) (mouse integer))
  (with-focused-view view
    (find-view-containing-point view (global-to-local view mouse))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; Returns the current mouse location.  This works only during a drag.
;;
(defmethod drag-mouse-location ((window drag-&-drop-window-mixin) &optional (local-p t))
  (rlet ((mouse :point))
    (oserr-check (#_GetDragMouse (drag-reference window) mouse (%null-ptr)))
    (when local-p
      (with-focused-view window
        (#_GlobalToLocal mouse)))
    (%get-long mouse)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; Returns the view the mouse is currently over.  This works only during a drag.
;;
(defmethod drag-mouse-view ((window drag-&-drop-window-mixin))
  (or (find-view-containing-point window (drag-mouse-location window) nil t) window))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; Function creates the little gray areas the Drag Manager manipulates during an
;; MCL-initiated drag. The item-region argument should be a Macintosh region that
;; defines the item's area; specifying a non-nil for the optional outline-p argument
;; will cause the function to install an outline of the item's region instead.
;;
(defmethod create-drag-item-bounds ((view simple-view) (item-reference integer)
                                    (item-region macptr) &optional (outline-p nil))
  (with-focused-view view
    (let ((temp-region (copy-region item-region))
          (global-point (local-to-global view (make-point 0))))
      (when outline-p
        (#_InsetRgn temp-region 1 1)
        (#_DiffRgn item-region temp-region temp-region)
        (#_OffsetRgn temp-region (point-h global-point) (point-v global-point)))
      (#_UnionRgn temp-region (drag-region (view-window view)) (drag-region (view-window view)))
      (with-dereferenced-handles ((rgn-ptr (drag-region (view-window view))))
        (oserr-check (#_SetDragItemBounds (drag-reference (view-window view)) item-reference (pref rgn-ptr :Region.rgnBBox))))))
  t)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; Drop location stuff
;;
(defmethod %resolve-alias-handle ((alias macptr))
  (rlet ((fsspec :FSSpec)
         (wasChanged :boolean))
    (#_ResolveAlias (%null-ptr) alias fsspec wasChanged)
    (let ((path (%path-from-fsspec fsspec)))
      (unless (directory-pathname-p path)
        (if (probe-file (format nil "~A:" path))
          (setf path (make-pathname :directory (append (pathname-directory path)
                                                       (list (mac-file-namestring path)))))))
      path)))

;
; A non-nil result from this function MUST be disposed via a call to #_AEDisposeDesc
;
(defmethod drag-get-drop-location ((window drag-&-drop-window-mixin))
  (let ((drop-location (make-record :AEDesc)))
    (oserr-check (#_GetDropLocation (drag-reference window) drop-location))
    (if (%null-ptr-p drop-location)
      (progn
        (#_AEDisposeDesc drop-location)
        nil)
      drop-location)))

(defmethod drag-get-drop-location-as-path ((window drag-&-drop-window-mixin))
  (let ((result nil))
    (with-aedescs (drop-location)
      (oserr-check (#_GetDropLocation (drag-reference window) drop-location))
      (when (and (not (%null-ptr-p drop-location))
                 (not (%null-ptr-p (rref drop-location :AEDesc.dataHandle)))
                 (eql (rref drop-location :AEDesc.descriptorType) #$rAliasType))
        (setf result (%resolve-alias-handle (rref drop-location :AEDesc.dataHandle)))))
    result))

#|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Example with a subclass of a Fred window
;;;
;;; Dragging selections from a drag-&-drop-fred window without any modifiers
;;; performs a "normal" drag (setting up the data ahead of time and allowing the
;;; Drag Manager to cache it).  Command-dragging does not cache the data ahead
;;; of time and forces the Drag Manager to call back to MCL for it.  Option-dragging
;;; promises and HFS file instead of the selected text.
;;;
;;; drag-&-drop-fred windows can accept either TEXT data or TEXT files during drags.
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(export '(fred-example))

(defun fred-example ()
  (make-instance 'drag-&-drop-fred))

(defclass drag-&-drop-fred (fred-window drag-&-drop-window-mixin)
  ())

(defun %drag-mouse-to-fred-position (fred-window)
  ; maps drag mouse location to fred buffer position
  (let ((pos (drag-mouse-location fred-window)))
    (fred-point-position fred-window pos)))

(defmethod drag-tracking-enter-view ((w drag-&-drop-fred))
  (unless (drag-within-sender-view-p w)
    (view-drag-hilite w t #@(0 0) (make-point (- (point-h (view-size w)) 15)
                                                (- (point-v (view-size w)) 15)))))

(defmethod drag-tracking-leave-view ((w drag-&-drop-fred))
  (view-drag-hilite w nil))

(defmethod drag-receive-drag ((w drag-&-drop-fred))
  (unless (drag-within-sender-view-p w)       ; don't allow drag&drop within same MCL window
    (let ((pos (%drag-mouse-to-fred-position w))        ; Fred insertion point for drop
          (text-flavor :|TEXT|)
          (some-item-used-p nil))
      (with-drag-items (item-reference w)
        (cond ((drag-item-flavor-exists-p w text-flavor item-reference)
               (setf some-item-used-p t)
               (with-drag-item-flavor-data (text-ptr w text-flavor item-reference)
                 (let* ((size (#_GetPtrSize text-ptr))
                        (new-string (make-string size)))
                   (without-interrupts
                    (dotimes (counter size)
                      (setf (elt new-string counter) (code-char (%get-byte text-ptr counter))))
                    (ed-insert-with-undo w new-string pos))
                   (invalidate-view w))))
              ((drag-item-flavor-exists-p w #$flavorTypeHFS item-reference)
               (with-drag-item-flavor-data (fsspec w #$flavorTypeHFS item-reference)
                 (when (eql (pref fsspec :HFSFlavor.fileType) text-flavor)
                   (setf some-item-used-p t)
                   (with-cursor *watch-cursor*
                     (let ((path (%path-from-fsspec (pref fsspec :HFSFlavor.fileSpec))))
                       (buffer-insert-file (fred-buffer w) path pos)
                       (invalidate-view w))))))))
      some-item-used-p)))

(defmethod drag-selection-p ((w drag-&-drop-fred) mouse-position)
  (with-focused-view w
    (point-in-region-p (uvref (frec w) 27)      ; hilite region within a Fred window
                       (global-to-local w mouse-position))))

(defmethod drag-begin-drag ((w drag-&-drop-fred) eventrecord)
  (with-cursor *arrow-cursor*
    (with-new-drag w eventrecord
      (multiple-value-bind (start end) (selection-range w)
        (let ((size (min (- end start) 30000))
              ($Buffer (#_NewPtr 0)))
          (unwind-protect
            (progn
              (cond ((option-key-p)
                     (drag-promise-hfs-flavor w 1 :|TEXT| :|CCL2|))
                    ((command-key-p)
                     (drag-promise-item-flavor w 1 :|TEXT|))
                    (t
                     (#_SetPtrSize $Buffer size)
                     (without-interrupts
                      (dotimes (counter size)
                        (%put-byte $Buffer (char-code (buffer-char (fred-buffer w) (+ start counter))) counter)))
                     (drag-add-item-flavor w 1 :|TEXT| $Buffer size)))
              (create-drag-item-bounds w 1 (uvref (frec w) 27) t))
            (#_DisposePtr $Buffer))
          t)))))

(defmethod drag-send-data ((w drag-&-drop-fred) (item-reference integer)
                           (flavor (eql :|TEXT|)))
  (%stack-block (($Buffer 30000))
    (multiple-value-bind (start end) (selection-range w)
      (let ((size (min (- end start) 30000)))
        (without-interrupts
         (dotimes (counter size)
           (%put-byte $Buffer (char-code (buffer-char (fred-buffer w) (+ start counter))) counter)))
        (drag-set-item-flavor-data w item-reference :|TEXT| $Buffer size)))
    t))

(defmethod drag-send-data ((w drag-&-drop-fred) (item-reference integer)
                           (flavor (eql $PromisedHFSObject)))
  (with-cursor *watch-cursor*
    (multiple-value-bind (start end) (selection-range w)
      (let ((temp (make-buffer))
            (drop-folder (drag-get-drop-location-as-path w))
            (title (window-title w))
            (counter 1)
            (path nil))
        (if (> (length title) 28)
          (setf title (format nil "~AÉ" (subseq title 0 28))))
        (flet ((unique-pathname ()
                 (make-pathname :directory (pathname-directory drop-folder)
                                :name (format nil "~A ~D" title counter)
                                :type "lisp")))
          (when drop-folder
            (setf path (unique-pathname))
            (loop while (probe-file path)
                  do (incf counter)
                  do (setf path (unique-pathname)))
            (buffer-insert temp (buffer-substring (fred-buffer w) start end))
            (buffer-write-file temp path :if-exists :append)
            (set-mac-file-type path :|TEXT|)
            (set-mac-file-creator path :|CCL2|)
            (rlet (($fs :FSSpec))
              (with-pstrs ((path-str (mac-namestring path)))
                (oserr-check (#_FSMakeFSSpec 0 0 path-str $fs))
                (drag-set-item-flavor-data w item-reference $PromisedHFSObject $fs #.(record-length :FSSpec))))
            t))))))



;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Example using multiple editable-text-dialog-items
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(export '(text-item-example))

(defun text-item-example ()
  (make-instance 'drag-window
    :window-type :document
    :view-position #@(3 40)
    :view-size #@(336 356)
    :view-font '("Geneva" 9 :srcor :plain)
    :view-subviews
    (list (make-dialog-item 'drop-text-field
                            #@(25 72)
                            #@(80 177)
                            ""
                            'nil
                            :wrap-p t
                            :view-font '("Geneva" 9 :srcor :plain)
                            :allow-returns t)
          (make-dialog-item 'drop-text-field
                            #@(125 72)
                            #@(80 177)
                            ""
                            'nil
                            :wrap-p t
                            :view-font '("Geneva" 9 :srcor :plain)
                            :allow-returns t))))

(defclass drag-window (color-dialog drag-&-drop-window-mixin)
  ())

(defclass drop-text-field (editable-text-dialog-item)
  ())

(defmethod drag-tracking-enter-view ((view drop-text-field))
  (unless (drag-within-sender-view-p (view-window view))
    (view-drag-hilite view t)))

(defmethod drag-tracking-leave-view ((view drop-text-field))
  (view-drag-hilite view nil))

(defun %drag-mouse-to-fred-position (fred-window)
  ; maps drag mouse location to fred buffer position
  (let ((pos (drag-mouse-location fred-window)))
    (fred-point-position fred-window pos)))

(defmethod drag-receive-drag ((view drop-text-field))
  (unless (drag-within-sender-view-p view)
    (let ((my-window (view-window view))
          (text-flavor :|TEXT|)
          (some-item-used-p nil))
      (with-drag-items (item-reference my-window)
        (cond ((drag-item-flavor-exists-p my-window text-flavor item-reference)
               (setf some-item-used-p t)
               (with-drag-item-flavor-data (text-ptr my-window text-flavor item-reference)
                 (let* ((size (#_GetPtrSize text-ptr))
                        (new-string (make-string size)))
                   (without-interrupts
                    (dotimes (counter size)
                      (setf (elt new-string counter) (code-char (%get-byte text-ptr counter))))
                    (ed-insert-with-undo view new-string))
                   (set-current-key-handler my-window view nil)
                   (invalidate-view view))))
              ((drag-item-flavor-exists-p my-window #$flavorTypeHFS item-reference)
               (with-drag-item-flavor-data (fsspec my-window #$flavorTypeHFS item-reference)
                 (when (eql (pref fsspec :HFSFlavor.fileType) text-flavor)
                   (setf some-item-used-p t)
                   (with-cursor *watch-cursor*
                     (let ((path (%path-from-fsspec (pref fsspec :HFSFlavor.fileSpec)))
                           (buffer (make-buffer)))
                       (buffer-insert-file buffer path)
                       (ed-insert-with-undo view (buffer-substring buffer 0 t))
                       (set-current-key-handler my-window view nil)
                       (invalidate-view view))))))
              ))
      some-item-used-p)))

(defmethod drag-selection-p ((view drop-text-field) mouse-position)
  (with-focused-view view
    (point-in-region-p (uvref (frec view) 27)      ; hilite region within a Fred item
                       (global-to-local view mouse-position))))

(defmethod drag-begin-drag ((view drop-text-field) eventrecord)
  (with-cursor *arrow-cursor*
    (with-new-drag (view-window view) eventrecord
      (multiple-value-bind (start end) (selection-range view)
        (let ((size (min (- end start) 30000)))
          (%stack-block (($Buffer 30000))
            (without-interrupts
             (dotimes (counter size)
               (%put-byte $Buffer (char-code (buffer-char (fred-buffer view) (+ start counter))) counter)))
            (drag-add-item-flavor (view-window view) 1 :|TEXT| $Buffer size)
            (create-drag-item-bounds view 1 (uvref (frec view) 27) t)))))))
|#